home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / cad / acadfont.zip / FROMAN.ZIP / DIMFRACD.LSP < prev    next >
Lisp/Scheme  |  1991-04-15  |  6KB  |  149 lines
  1. (defun getval (n e) (cdr (assoc n e)))
  2.  
  3. (defun parse_etxt ( / tht, tloc, trot, txtlen, si, numer, numer1,
  4.                        denom, denom1, frac, den, num)
  5.    (setq tht (cdr (assoc 40 en1)))     ;Get text height
  6.    (setq tloc (cdr (assoc 10 en1)))    ;Get text location
  7.    (setq trot (cdr (assoc 50 en1)))    ;Get text rotation
  8.    (setq txtlen (strlen etxt))
  9.    (setq si 1 slloc 0)
  10.    (while (<= si txtlen)
  11.      (progn
  12.        (if (= "/" (substr etxt si 1))
  13.           (setq slloc si)
  14.        )
  15.        (setq si (1+ si))
  16.    ))
  17.    (if (> slloc 0)
  18.       (progn                           ;Calculate value of fraction
  19.          (setq denom "" denom1 "" numer "" numer1 ""
  20.                maskl 0 maskr 0 ctest (1+ ctest))
  21.          (if (< slloc txtlen)
  22.               (setq denom (substr etxt (1+ slloc) 1)))
  23.          (if (< (1+ slloc) txtlen)
  24.               (setq denom1 (substr etxt (+ slloc 2) 1)))
  25.          (if (> slloc 1)
  26.               (setq numer (substr etxt (1- slloc) 1)))
  27.          (if (> slloc 2)
  28.               (setq numer1 (substr etxt (- slloc 2) 1)))
  29.          (setq num (atof numer))
  30.          (if (and (>= numer1 "0")(<= numer1 "9"))
  31.                (setq num (+ num (* 10 (atof numer1)))
  32.                      maskl 1))
  33.          (setq den (atof denom))
  34.          (if (and (>= denom1 "0")(<= denom1 "9"))
  35.                (setq den (+ (* 10 den) (atof denom1))
  36.                      maskr 1))
  37.          (setq frac (fix (+ 0.5 (* 64 (/ num den)))))
  38.          (setq frac (+ frac 129))    ;1 = 1/64 = %%130
  39.          (if (> slloc 3)
  40.             (if (or (= (substr etxt (- slloc (+ 2 maskl)) 1) " ")
  41.                     (= (substr etxt (- slloc (+ 2 maskl)) 1) "-"))
  42.                     (setq maskl (1+ maskl))))
  43.        (setq etxt (strcat (substr etxt 1 (- slloc (+ 2 maskl)))
  44.                "%%" (itoa frac) (substr etxt (+ slloc 2 maskr))))
  45.        (setq movdis (+ movdis tht))   ;Move text height distance
  46.       )  ;progn
  47.    )
  48. )
  49.  
  50. (defun fract_text ( / justi, ctest, movvup)      ;Uses entity en1
  51.     (setq etxt (cdr (assoc 1 en1)))
  52.     (setq justi (cdr (assoc 72 en1)))
  53.     (setq ctest 0 movdis 0)          ;Initialize
  54.     (parse_etxt)                     ;1st try
  55.     (if (> slloc 0) (parse_etxt))    ;2nd try
  56.     (if (> slloc 0) (parse_etxt))
  57.     (if (> slloc 0) (parse_etxt))
  58.     (if (> slloc 0) (parse_etxt))
  59.     (if (> slloc 0) (parse_etxt))    ;6th try
  60.     (if (> trot 0.5) (setq movvup movdis movdis 0) (setq movvup 0))
  61.     (if (> ctest 0)                  ;Only update entity if "/" found
  62.        (progn
  63.           (setq en1 (subst
  64.                         (cons 7 "FROMAND")
  65.                         (assoc 7 en1)
  66.                         en1
  67.                     )
  68.                 en1 (subst
  69.                         (cons 1 etxt)
  70.                         (assoc 1 en1)
  71.                         en1
  72.                     )
  73.                 en1 (subst
  74.                          (cons 10 (list (+ (car tloc) movdis)
  75.                                   (+ (cadr tloc) movvup) (cadr (cdr tloc))))
  76.                          (assoc 10 en1)
  77.                          en1
  78.                     )
  79.           )
  80.           (entmod en1)               ;Modify entity
  81.        )   ;prog
  82.     )    ;if slloc > 0
  83. )
  84.  
  85. (defun dmfracd( / n, plen)
  86.   (command ".SETVAR" "cmdecho" 0)        ;Don't want to see commands for a while
  87.   (setq rgmd (getvar "REGENMODE"))       ;Save REGENMODE
  88.   (setvar "REGENMODE" 0)                 ;Prevent automatic drawing regens
  89.   (setq styl (getvar "TEXTSTYLE"))       ;Save current Text Style
  90.   (command ".style" "FROMAND" "FROMAND" 0 1 0 "n" "n" "n") ;Load FROMAND style
  91.   (command ".style" styl "" "" "" "" "" "" "")  ;Reset text style
  92.   (command ".SETVAR" "cmdecho" 1)        ;OK to see commands now
  93.   (princ "\nSelect Dimensions to be converted to fractions : ")
  94.   (setq ss (ssget))                      ;Select Objects
  95.   (setq plen (sslength ss))              ;plen = number of items selected
  96.   (setq n 0)                             ;Reset Index to 0
  97.   (if (> plen 0)                         ;Do function only if items are selected
  98.     (while (< n plen)                    ;Loop PLEN times
  99.       (setq e1 (ssname ss n))            ;E1 = Entity name
  100.       (setq en (entget e1))              ;EN = Entity
  101.       (setq et (cdr (assoc 0 en)))       ;ET = Entity type
  102.       (setq en1 en)
  103.       (if (= et "TEXT") (fract_text))    ;Convert text string
  104.       (if (= et "DIMENSION")             ;If dimension, explode, then convert
  105.         (progn
  106.            (setq e0 (entlast))           ;Find last entity in drawing database
  107.            (setq en1 (entnext e0))       ;  so that entities added from
  108.            (while (not (null en1))       ;  explode can be distinguished
  109.               (setq e0 en1)
  110.               (setq en1 (entnext e0))
  111.            )
  112.            (command "explode" (getval -1 en))
  113.            (setq s0 (ssadd))      ;Create an empty selection set
  114.            (while (entnext e0) (ssadd (setq e0 (entnext e0)) s0))
  115.            (command "chprop" s0 "" "c" "bylayer" "lt" "bylayer"
  116.                                       "la" (getval 8 en) "")
  117.            (setq plen1 (sslength s0))
  118.            (setq n1 0)
  119.            (if (> plen1 0)       ;Change Text String as needed
  120.               (while (< n1 plen1)
  121.                  (progn
  122.                    (setq e11 (ssname s0 n1))
  123.                    (setq en1 (entget e11))
  124.                    (setq et1 (cdr (assoc 0 en1)))
  125.                    (if (= et1 "TEXT") (fract_text))
  126.                    (setq n1 (1+ n1))
  127.                  )    ;progn
  128.               )    ;while
  129.            )       ;if
  130.       ))
  131.       (setq n (1+ n))
  132.     )   ;while
  133.   )     ;if plen
  134.   (setvar "REGENMODE" rgmd)              ;Restore drawing regen mode
  135.   (print "DIMFRAC Complete ...")
  136.   (princ)
  137. )
  138.  
  139. (defun C:DIMFRACD ()          ;This allows a shorter ACAD.LSP load
  140.    (dmfracd)                  ;  with an automatic program load when required
  141. )
  142.  
  143. ; Add the lines (defun C:DIMFRACD ()
  144. ;                    (if (not dmfracd)
  145. ;                        (progn (princ "LOADING DIMFRACD")
  146. ;                               (load "dimfracd") (dmfracd)
  147. ;               )))
  148. ;    to C::STARTUP area of ACAD.LSP
  149.